home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / gnu / emacs / emacs1857 / bin_d2.zoo / lisp / bytecomp.el < prev    next >
Lisp/Scheme  |  1991-12-02  |  41KB  |  1,160 lines
  1. ;; Compilation of Lisp code into byte code.
  2. ;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 1, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'byte-compile)
  21.  
  22. (defvar byte-compile-constnum -1
  23.   "Transfer vector index of last constant allocated.")
  24. (defvar byte-compile-constants nil
  25.   "Alist describing contents to put in transfer vector.
  26. Each element is (CONTENTS . INDEX)")
  27. (defvar byte-compile-macro-environment nil
  28.   "Alist of (MACRONAME . DEFINITION) macros defined in the file
  29. which is being compiled.")
  30. (defvar byte-compile-pc 0
  31.   "Index in byte string to store next opcode at.")
  32. (defvar byte-compile-output nil
  33.   "Alist describing contents to put in byte code string.
  34. Each element is (INDEX . VALUE)")
  35. (defvar byte-compile-depth 0
  36.   "Current depth of execution stack.")
  37. (defvar byte-compile-maxdepth 0
  38.   "Maximum depth of execution stack.")
  39.  
  40. (defconst byte-varref 8
  41.   "Byte code opcode for variable reference.")
  42. (defconst byte-varset 16
  43.   "Byte code opcode for setting a variable.")
  44. (defconst byte-varbind 24
  45.   "Byte code opcode for binding a variable.")
  46. (defconst byte-call 32
  47.   "Byte code opcode for calling a function.")
  48. (defconst byte-unbind 40
  49.   "Byte code opcode for unbinding special bindings.")
  50.  
  51. (defconst byte-constant 192
  52.   "Byte code opcode for reference to a constant.")
  53. (defconst byte-constant-limit 64
  54.   "Maximum index usable in  byte-constant  opcode.")
  55.  
  56. (defconst byte-constant2 129
  57.   "Byte code opcode for reference to a constant with vector index >= 0100.")
  58.  
  59. (defconst byte-goto 130
  60.   "Byte code opcode for unconditional jump")
  61.  
  62. (defconst byte-goto-if-nil 131
  63.   "Byte code opcode for pop value and jump if it's nil.")
  64.  
  65. (defconst byte-goto-if-not-nil 132
  66.   "Byte code opcode for pop value and jump if it's not nil.")
  67.  
  68. (defconst byte-goto-if-nil-else-pop 133
  69.   "Byte code opcode for examine top-of-stack, jump and don't pop it if it's nil,
  70. otherwise pop it.")
  71.  
  72. (defconst byte-goto-if-not-nil-else-pop 134
  73.   "Byte code opcode for examine top-of-stack, jump and don't pop it if it's not nil,
  74. otherwise pop it.")
  75.  
  76. (defconst byte-return 135
  77.   "Byte code opcode for pop value and return it from byte code interpreter.")
  78.  
  79. (defconst byte-discard 136
  80.   "Byte code opcode to discard one value from stack.")
  81.  
  82. (defconst byte-dup 137
  83.   "Byte code opcode to duplicate the top of the stack.")
  84.  
  85. (defconst byte-save-excursion 138
  86.   "Byte code opcode to make a binding to record the buffer, point and mark.")
  87.  
  88. (defconst byte-save-window-excursion 139
  89.   "Byte code opcode to make a binding to record entire window configuration.")
  90.  
  91. (defconst byte-save-restriction 140
  92.   "Byte code opcode to make a binding to record the current buffer clipping restrictions.")
  93.  
  94. (defconst byte-catch 141
  95.   "Byte code opcode for catch.  Takes, on stack, the tag and an expression for the body.")
  96.  
  97. (defconst byte-unwind-protect 142
  98.   "Byte code opcode for unwind-protect.  Takes, on stack, an expression for the body
  99. and an expression for the unwind-action.")
  100.  
  101. (defconst byte-condition-case 143
  102.   "Byte code opcode for condition-case.  Takes, on stack, the variable to bind,
  103. an expression for the body, and a list of clauses.")
  104.  
  105. (defconst byte-temp-output-buffer-setup 144
  106.   "Byte code opcode for entry to with-output-to-temp-buffer.
  107. Takes, on stack, the buffer name.
  108. Binds standard-output and does some other things.
  109. Returns with temp buffer on the stack in place of buffer name.")
  110.  
  111. (defconst byte-temp-output-buffer-show 145
  112.   "Byte code opcode for exit from with-output-to-temp-buffer.
  113. Expects the temp buffer on the stack underneath value to return.
  114. Pops them both, then pushes the value back on.
  115. Unbinds standard-output and makes the temp buffer visible.")
  116.  
  117. (defconst byte-nth 56)
  118. (defconst byte-symbolp 57)
  119. (defconst byte-consp 58)
  120. (defconst byte-stringp 59)
  121. (defconst byte-listp 60)
  122. (defconst byte-eq 61)
  123. (defconst byte-memq 62)
  124. (defconst byte-not 63)
  125. (defconst byte-car 64)
  126. (defconst byte-cdr 65)
  127. (defconst byte-cons 66)
  128. (defconst byte-list1 67)
  129. (defconst byte-list2 68)
  130. (defconst byte-list3 69)
  131. (defconst byte-list4 70)
  132. (defconst byte-length 71)
  133. (defconst byte-aref 72)
  134. (defconst byte-aset 73)
  135. (defconst byte-symbol-value 74)
  136. (defconst byte-symbol-function 75)
  137. (defconst byte-set 76)
  138. (defconst byte-fset 77)
  139. (defconst byte-get 78)
  140. (defconst byte-substring 79)
  141. (defconst byte-concat2 80)
  142. (defconst byte-concat3 81)
  143. (defconst byte-concat4 82)
  144. (defconst byte-sub1 83)
  145. (defconst byte-add1 84)
  146. (defconst byte-eqlsign 85)
  147. (defconst byte-gtr 86)
  148. (defconst byte-lss 87)
  149. (defconst byte-leq 88)
  150. (defconst byte-geq 89)
  151. (defconst byte-diff 90)
  152. (defconst byte-negate 91)
  153. (defconst byte-plus 92)
  154. (defconst byte-max 93)
  155. (defconst byte-min 94)
  156.  
  157. (defconst byte-point 96)
  158. ;(defconst byte-mark 97) no longer generated -- lisp code shouldn't call this very frequently
  159. (defconst byte-goto-char 98)
  160. (defconst byte-insert 99)
  161. (defconst byte-point-max 100)
  162. (defconst byte-point-min 101)
  163. (defconst byte-char-after 102)
  164. (defconst byte-following-char 103)
  165. (defconst byte-preceding-char 104)
  166. (defconst byte-current-column 105)
  167. (defconst byte-indent-to 106)
  168. ;(defconst byte-scan-buffer 107) no longer generated
  169. (defconst byte-eolp 108)
  170. (defconst byte-eobp 109)
  171. (defconst byte-bolp 110)
  172. (defconst byte-bobp 111)
  173. (defconst byte-current-buffer 112)
  174. (defconst byte-set-buffer 113)
  175. (defconst byte-read-char 114)
  176. ;(defconst byte-set-mark 115)       ;obsolete
  177. (defconst byte-interactive-p 116)
  178.  
  179. (defun byte-recompile-directory (directory &optional arg)
  180.   "Recompile every .el file in DIRECTORY that needs recompilation.
  181. This is if a .elc file exists but is older than the .el file.
  182. If the .elc file does not exist, offer to compile the .el file
  183. only if a prefix argument has been specified." 
  184.   (interactive "DByte recompile directory: \nP")
  185.   (save-some-buffers)
  186.   (setq directory (expand-file-name directory))
  187.   (let ((files (directory-files directory nil "\\.el\\'"))
  188.     (count 0)
  189.     source dest)
  190.     (while files
  191.       (if (and (not (auto-save-file-name-p (car files)))
  192.            (setq source (expand-file-name (car files) directory))
  193.            (setq dest (concat (file-name-sans-versions source) "c"))
  194.            (if (file-exists-p dest)
  195.            (file-newer-than-file-p source dest)
  196.            (and arg (y-or-n-p (concat "Compile " source "? ")))))
  197.       (progn (byte-compile-file source)
  198.          (setq count (1+ count))))
  199.       (setq files (cdr files)))
  200.     (message "Done (Total of %d file%s compiled)"
  201.          count (if (= count 1) "" "s"))))
  202.  
  203. (defun byte-compile-file (filename)
  204.   "Compile a file of Lisp code named FILENAME into a file of byte code.
  205. The output file's name is made by appending \"c\" to the end of FILENAME."
  206.   (interactive "fByte compile file: ")
  207.   ;; Expand now so we get the current buffer's defaults
  208.   (setq filename (expand-file-name filename))
  209.   (message "Compiling %s..." filename)
  210.   (let ((inbuffer (get-buffer-create " *Compiler Input*"))
  211.     (outbuffer (get-buffer-create " *Compiler Output*"))
  212.     (byte-compile-macro-environment nil)
  213.     (case-fold-search nil)
  214.     sexp)
  215.     (save-excursion
  216.       (set-buffer inbuffer)
  217.       (erase-buffer)
  218.       (insert-file-contents filename)
  219.       (goto-char 1)
  220.       (set-buffer outbuffer)
  221.       (emacs-lisp-mode)
  222.       (erase-buffer)
  223.       (while (save-excursion
  224.            (set-buffer inbuffer)
  225.            (while (progn (skip-chars-forward " \t\n\^l")
  226.                  (looking-at ";"))
  227.          (forward-line 1))
  228.            (not (eobp)))
  229.     (setq sexp (read inbuffer))
  230.     (print (byte-compile-file-form sexp) outbuffer))
  231.       (set-buffer outbuffer)
  232.       (goto-char 1)
  233.       ;; In each defun or autoload, if there is a doc st